home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / CorePackages / hook.tcl < prev    next >
Encoding:
Text File  |  2001-01-16  |  5.7 KB  |  205 lines
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  AlphaTcl - core Tcl engine
  4.  # 
  5.  #  FILE: "hook.tcl"
  6.  #                                    created: 18/7/97 {5:10:18 pm} 
  7.  #                                last update: 01/16/2001 {18:45:28 PM} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <vince@santafe.edu>
  10.  #    mail: 317 Paseo de Peralta
  11.  #          Santa Fe, NM 87501, USA
  12.  #     www: <http://www.santafe.edu/~vince/>
  13.  #  
  14.  # Copyright (c) 1997-2000  Vince Darley, all rights reserved
  15.  #  
  16.  # Description: 
  17.  #  
  18.  #  Allows procedures to be registered and called at a specific time,
  19.  #  according to the current mode.  This means it is no longer necessary
  20.  #  or desireable to rename the standard hook procedures.  Previously
  21.  #  you had to do this:
  22.  #  
  23.  #   if {[info commands blahSaveHook] == ""} {
  24.  #       rename saveHook blahSaveHook
  25.  #       proc saveHook {name} { ... ; blahSaveHook $name}
  26.  #   }
  27.  # 
  28.  #  But now you just need to add a line like this to your code:
  29.  #  
  30.  #      hook::register 'hook-name' 'your proc' 'mode' ?... 'mode'?
  31.  # 
  32.  #  Here are two examples:
  33.  #  
  34.  #      hook::register savePostHook codeWarrior_modified "C++" "C"
  35.  #      hook::register savePostHook ftpPostHook
  36.  #  
  37.  #  If you don't include a 'mode', then your proc will be called no
  38.  #  matter what the current mode is.   Avoid this unless absolutely
  39.  #  necessary.  
  40.  #  
  41.  #  Use of such lists as 'savePostHooks' is obsolete.
  42.  #  These lists are ignored, use hook::register instead.
  43.  #  
  44.  #  History
  45.  # 
  46.  #  modified by  rev reason
  47.  #  -------- --- --- -----------
  48.  #  18/7/97  VMD 1.0 original
  49.  #  22/7/97  VMD 1.1 fixed all bugs ;-) and added the above examples.
  50.  # ###################################################################
  51.  ##
  52.  
  53. namespace eval hook {}
  54. set hook::version 1.1
  55.  
  56. proc hook::register {hook procname args} {
  57.     if {![llength $args]} {lappend args "*"}
  58.     namesp ::hook::${hook}
  59.     global hook::${hook}
  60.     foreach mode $args {
  61.     if {![info exists hook::${hook}($mode)] || \
  62.       [lsearch -exact [set hook::${hook}($mode)] $procname] == -1} {
  63.         lappend hook::${hook}($mode) $procname
  64.     }
  65.     }
  66. }
  67.  
  68. proc hook::anythingRegistered {hook {_detail ""}} {
  69.     global hook::${hook}
  70.     if {[string length $_detail]} {
  71.     return [info exists hook::${hook}($_detail)]
  72.     } else {
  73.     return [array exists hook::$hook]
  74.     }
  75. }
  76.  
  77. proc hook::information {{hook ""} {_mode ""}} {
  78.     if {$hook == ""} {
  79.     # just list the names of hooks which exist
  80.     set l [uplevel #0 {info vars hook::*}]
  81.     foreach a $l {
  82.         if {![uplevel #0 "array exists $a"]} {
  83.         set i [lsearch $l $a]
  84.         set l [lreplace $l $i $i]
  85.         }
  86.     }
  87.     regsub -all "hook::" $l "" l
  88.     return $l
  89.     } else {
  90.     global hook::${hook}
  91.     if {${_mode} == ""} {
  92.         # return all the attached procs for given hook
  93.         if {[array exists hook::$hook]} {
  94.         return [array get hook::${hook}]
  95.         } else {
  96.         return ""
  97.         }
  98.     } else {
  99.         if {[info exists hook::${hook}($_mode)]} {
  100.         return [set hook::${hook}($_mode)]
  101.         } else {
  102.         return ""
  103.         }
  104.     }
  105.     }
  106. }
  107.  
  108. proc hook::deregister {hook {procname ""} args} {
  109.     if {![llength $args]} {set args "*"}
  110.     namesp hook::${hook}
  111.     global hook::${hook}
  112.     if {$procname == ""} { 
  113.     # clear all hooks
  114.     unset hook::${hook} 
  115.     } else {        
  116.     foreach mode $args {
  117.         if {[info exists hook::${hook}($mode)] && \
  118.           [set i [lsearch -exact [set hook::${hook}($mode)] $procname]] != -1} {
  119.         set new [lreplace [set hook::${hook}($mode)] $i $i]
  120.         if {[llength $new]} {
  121.             set hook::${hook}($mode) $new
  122.         } else {
  123.             unset hook::${hook}($mode)
  124.         }
  125.         }
  126.     }
  127.     }
  128. }
  129.    
  130. proc hook::callAll {hook {_mode ""} args} {
  131.     if {[catch "global hook::${hook}"]} {return 0}
  132.     if {$_mode == ""} { global mode ; set _mode $mode }
  133.     set err 0
  134.     if {[info exists hook::${hook}(*)]} {
  135.     foreach proc [set hook::${hook}(*)] {
  136.         incr err [catch {uplevel \#0 [list eval $proc $args]}]
  137.     }
  138.     }
  139.     if {$_mode != "*" && [info exists hook::${hook}($_mode)]} {  
  140.     foreach proc [set hook::${hook}($_mode)] {
  141.         incr err [catch {uplevel \#0 [list eval $proc $args]}]
  142.     }
  143.     }
  144.     return $err
  145. }  
  146.  
  147. ## 
  148.  # -------------------------------------------------------------------------
  149.  # 
  150.  # "hook::callUntil" --
  151.  # 
  152.  #  Rather like 'callAll', except it is used to implement a stacked
  153.  #  hook.  This is a hook in which registered procedures are called
  154.  #  one by one, _until_ one of them claims to be able to handle
  155.  #  the request.  It does that by taking action and returning '1'.
  156.  #  Procedures which cannot handle the action return 0.
  157.  #  
  158.  #  Procedures should not throw an error (although currently we
  159.  #  are kind enough to ignore it).
  160.  # -------------------------------------------------------------------------
  161.  ##
  162. proc hook::callUntil {hook {_mode ""} args} {
  163.     if {[catch "global hook::${hook}"]} {return 0}
  164.     if {$_mode == ""} { global mode ; set _mode $mode }
  165.     if {[info exists hook::${hook}(*)]} {
  166.     foreach proc [set hook::${hook}(*)] {
  167.         if {![catch {uplevel \#0 [list eval $proc $args]} res] && $res} {
  168.         return 1
  169.         }
  170.     }
  171.     }
  172.     if {$_mode != "*" && [info exists hook::${hook}($_mode)]} {  
  173.     foreach proc [set hook::${hook}($_mode)] {
  174.         if {![catch {uplevel \#0 [list eval $proc $args]} res] && $res} {
  175.         return 1
  176.         }
  177.     }
  178.     }
  179.     return 0
  180. }  
  181.  
  182. proc hook::callUntilOk {hook {_mode ""} args} {
  183.     if {[catch "global hook::${hook}"]} {error "No hooks were ok"}
  184.     if {$_mode == ""} { global mode ; set _mode $mode }
  185.     if {[info exists hook::${hook}(*)]} {
  186.     foreach proc [set hook::${hook}(*)] {
  187.         if {![catch {uplevel \#0 [list eval $proc $args]} res]} {
  188.         return $res
  189.         }
  190.     }
  191.     }
  192.     if {$_mode != "*" && [info exists hook::${hook}($_mode)]} {  
  193.     foreach proc [set hook::${hook}($_mode)] {
  194.         if {![catch {uplevel \#0 [list eval $proc $args]} res]} {
  195.         return $res
  196.         }
  197.     }
  198.     }
  199.     error "No hooks were ok"
  200. }  
  201.  
  202.  
  203.  
  204.  
  205.